home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Toolbox classes / TextEdit < prev    next >
Text File  |  1998-07-15  |  10KB  |  441 lines
  1. \ Oct95 JRF Added noClip to Activate: & Deactivate: per MRH suggestion
  2.     \ modified New: to enable outline highliting of inactive TE
  3.  
  4. \ 25May93 DBH  Added lastchar: to commonize a routine.
  5.     \ added kludge to #lines: to fix a bug.
  6.     \ Completely reworked currentline: to fix a speed problem.
  7.  
  8. \ 15May93 DBH  Added textaddr: method to improve readability and code reuse.
  9.     \ Use textaddr: self in getline: .
  10.     \ Deleted addrlinestart: method because it is never reused.
  11.     \ Added lineEnd: method, so we can move there easily.
  12.     \ Delte general class declaration.
  13. \ 11May93 DBH  fixed getLine: so null is returned if last char in TE is
  14.     \ a carriage return.  Added getpoint: and idle: methods.
  15.  
  16. \ 3Sep96 mrh  added values lineStart and lineEnd, set by a getLine: call
  17. \ Jan 98 mrh  fixed TE scrap stuff for PowerPC
  18.  
  19.  
  20. PPC? [IF]  syscall TESetScrapLength  [THEN]        \ not a call on 68k
  21.  
  22. need terecord
  23.  
  24. variable OFFSET  \ used in GetScrap call
  25.  
  26. 0    value    LINESTART    \ these are set when we call getLine: - useful sometimes
  27. 0    value    LINEEND
  28.  
  29.  
  30. \ some routines to handle the clipboard
  31.  
  32. : TODESK        ( -- oserr )
  33.     ZeroScrap ?EXIT                    \ out if error
  34. [ ppc? ] [if]
  35.     TEGetScrapLength                \ length
  36. [else]
  37.     global TEScrpLength w@
  38. [then]
  39.     'type TEXT                      \ theType
  40.     TEScrapHandle  @
  41.     PutScrap
  42. ;
  43.  
  44.  
  45.  : FROMDESK     ( -- oserr )
  46.     TEScrapHandle
  47.     'type TEXT      \ theType
  48.     offset
  49.     GetScrap
  50. [ ppc? ] [if]
  51.     dup 0>= IF  TESetScrapLength
  52.                 0                            \ no error
  53.             THEN
  54. [else]
  55.     dup 0>=    IF  global TEScrpLength w!        \ store scrap length
  56.                 0                            \ no error
  57.             THEN
  58. [then]
  59. ; 
  60.  
  61.  
  62.  
  63. : SELCUT
  64.         actW IF cut: [ actW ] THEN ;
  65.  
  66. : SELCOPY
  67.         actW IF copy: [ actW ] THEN ;
  68.  
  69. : SELPASTE
  70.     actW IF  paste: [ actW ]  THEN ;
  71.  
  72. : SELCLEAR
  73.     actW IF  clear: [ actW ]  THEN ;
  74.  
  75.  
  76. :class  RGBColor  super{ object }
  77. 68k_record
  78. {    uint    red
  79.     uint    green
  80.     uint    blue
  81. }
  82.  
  83. :m SETCOLOR:    \ ( red green blue -- )
  84.     put: blue  put: green  put: red  ;m
  85.  
  86. :m GETCOLOR:    \ ( -- red green blue )
  87.     get: red  get: green  get: blue  ;m
  88.  
  89. ;class
  90.  
  91. \ Note an object of class RGBColor will start off black, unless we change it.
  92.  
  93.  
  94. :class TextStyle  super{ object }
  95.  
  96. public
  97. 68k_record
  98. {    int            tsFont
  99.     byte        tsFace
  100.     int            tsSize
  101.     RGBColor    tsColor
  102. }
  103.  
  104. :m classinit:    9 put: tsSize  ;m
  105.  
  106. ;class
  107.  
  108. TextStyle    theStyle
  109.  
  110. \ syscall TENew
  111. \ syscall TEStyleNew
  112. \ syscall TextFont
  113. \ syscall TextSize
  114. \ syscall    TESetStyle
  115.  
  116. handle    textHandle
  117.  
  118.  
  119. :CLASS TextEdit super{ object }
  120.  
  121.     handle    TEHandle
  122. public
  123.     bool    styles?
  124. end_public
  125.  
  126. :m useStyles:    set: styles?  ;m        \ get rid of it when I fix the bug!
  127.  
  128. :m new:    { dest view -- }
  129.  
  130.     9 TextSize                \ need a smallish initial default value
  131.     dest
  132.     view
  133.     get: styles?
  134.     IF        TEStyleNew
  135.     ELSE    TENew
  136.     THEN  put: TEHandle
  137.  
  138.     2 1                    \ 2 selects OutlineHilite feature
  139.     get: TEHandle        \ 1 sets its flag
  140.     TEFeatureFlag
  141.     drop                \ don't want the returned result
  142. ;m
  143.  
  144. :m handle:    ( -- tehandle )
  145.     get: TEHandle ;m
  146.  
  147. :m ptr:    ( -- teRecord )
  148.     ptr: TEHandle ;m
  149.  
  150.  
  151. :m noWrap:
  152.     ptr: self  noWrap: teRecord  ;m
  153.  
  154. :m WrapIt:
  155.     ptr: self  wrapIt: teRecord  ;m
  156.  
  157.  
  158. :m >font:  ( font# -- )
  159.     put: ivar> tsFont in theStyle
  160.     1 ( font )  theStyle  false  get: TEHandle  TESetStyle
  161. ;m
  162.  
  163. :m >fontSize:  ( n -- )
  164.     put: ivar> tsSize in theStyle
  165.     4 ( size )  theStyle  false  get: TEHandle  TESetStyle
  166. ;m
  167.  
  168. :m >color:  ( red green blue -- )
  169.     setColor: ivar> tsColor in theStyle
  170.     8 ( color )  theStyle  false  get: TEHandle  TESetStyle
  171. ;m
  172.  
  173. :m >style:  ( n -- )
  174.     put: ivar> tsFace in theStyle
  175.     2 ( face )  theStyle  false  get: TEHandle  TESetStyle
  176. ;m
  177.  
  178. :m SETVIEWRECT:  { left top rt bot \ adr -- }
  179.     ptr: TEHandle  -> adr    \ ptr: TEHandle setview: teRecord ;m  ??    \ 19May93 DBH
  180.     top  adr  8 +  w!  left  adr 10 + w!
  181.     bot  adr 12 +  w!    rt  adr 14 + w!  ;m
  182.  
  183.  
  184. :m LINEHEIGHT:  ( -- n )
  185.     ptr: TEHandle lineHeight: teRecord ;m
  186.  
  187. \ :m #lines:    ( -- n)
  188. \    ptr: TEHandle  #lines: teRecord    \ note message to class
  189. \    ;m
  190.  
  191. :m cut:
  192.     get: TEHandle  TECut
  193.     todesk  drop ;m            \ not looking at error
  194.  
  195. :m copy:
  196.     get: TEHandle  TECopy
  197.     todesk drop ;m            \ not looking at error
  198.  
  199. :m paste:
  200.     fromdesk  ?EXIT            \ out if error
  201.     get: TEHandle  TEPaste ;m
  202.  
  203. :m clear:
  204.     0 0  SetOrigin
  205.     get: TEHandle  TEDelete  ;m
  206.  
  207.  
  208. :m update:    \ ( rptr -- )
  209.     0 0  SetOrigin
  210.     get: TEHandle  TEUpdate
  211. ;m
  212.     
  213.  
  214. :m SCROLL:        \ ( dx dy -- )
  215.     0 0  SetOrigin
  216.     get: TEHandle  TEScroll  ;m
  217.  
  218.  
  219. :m size: ( -- len )  \ returns the length of the text
  220.     ptr: TEHandle  size: teRecord ;m         \ note message to class
  221.  
  222. :m TextHandle:        \ ( -- hndl )
  223.     get: TEhandle  TEGetText  dup put: textHandle  ;m
  224.  
  225. :m textaddr:        \ ( -- addr )    \ addr of the first char of the TE text
  226.     textHandle: self  @  ;m
  227.  
  228. :m get:    ( -- $addr len )
  229.     textaddr: self
  230.     size: self  ;m
  231.  
  232. :m getText&lock:  ( -- hState addr len )
  233.     get: self                \ I'll do this first, before locking the handle, since
  234.                             \  I can't assume TE won't unlock it
  235.     getState: textHandle  down
  236.     lock: textHandle  ;m
  237.  
  238. :m >hState:  ( hState -- )
  239.     textHandle: self drop
  240.     setState: textHandle
  241. ;m
  242.  
  243. :m put: ( $addr len -- )
  244.     get: TEHandle  TESetText
  245.     update: self  ;m
  246.  
  247. :m insert:  ( addr len -- )
  248.     get: TEHandle  TEInsert
  249. ;m
  250.  
  251. :m activate:
  252.     noClip
  253.     get: TEHandle  TEActivate ;m
  254.  
  255. :m deactivate:
  256.     noClip
  257.     get: TEHandle  TEDeactivate ;m
  258.  
  259. :m release:
  260.     get: TEHandle  TEDispose
  261.     clear: TEHandle ;m
  262.  
  263. :m click:
  264.     where: fEvent  g->l
  265.     mods: fevent $ 200 and  0<> negate    \ extend if shift key (need a
  266.                                         \  Pascal-style boolean
  267.     handle: self  TEClick
  268.     ;m
  269.  
  270. :m select:  ( start end -- )  \ hilites the given range
  271.     get: TEHandle  TESetSelect ;m
  272.  
  273. :m selectAll:  \ hilites all of the text
  274.     0 ( start)
  275.     size: self  ( end)
  276.     select: self ;m
  277.  
  278. :m selStart:  ( -- n )
  279.     ptr: TEHandle selStart: teRecord ;m
  280.  
  281. :m selEnd:  ( -- n )
  282.     ptr: TEHandle selEnd: teRecord ;m
  283.  
  284. :m lastchar:  ( -- char )    \ return last character in TE
  285.     textaddr: self  size: self 1- + c@  ;m
  286.  
  287.  
  288. :m key:  { char \ bSel eSel -- }
  289.         \ TE for some reason doesn't handle forward delete, so we
  290.         \  have to special-case it.
  291.  
  292.     char 127 =
  293.     IF                            \ yes, it's forward delete
  294.         selStart: self -> bSel
  295.         selEnd: self   -> eSel
  296.         bSel eSel =
  297.         IF    eSel  size: self  >=  ?EXIT
  298.             eSel 1+ dup  select: self
  299.         ELSE
  300.             eSel  size: self <
  301.             IF  bSel eSel 1+  select: self  THEN
  302.         THEN
  303.         8  -> char
  304.     THEN
  305.     char  get: TEHandle  TEKey
  306. ;m
  307.  
  308.  
  309. 0 value kludge
  310.  
  311. :m #lines:    ( -- n )
  312.     0 -> kludge
  313.     ptr: TEHandle  #lines: class_as> teRecord
  314.     lastchar: self  ret = IF -1 -> kludge 1+ THEN    \ kludge Apple line numbering scheme!!
  315. ;m
  316.  
  317. \ given the zero-based line number, return the character# of the start of
  318. \ that line
  319.  
  320. :m at:  { n -- linestart }
  321.     n ( kludge + ) 1+  #lines: self >     \ abort" TE linestart index out of range"
  322.     IF  #lines: self  1- -> n  THEN
  323.     ptr: TEHandle  addrLineStart: class_as> teRecord
  324.     n 2* + w@
  325. \    dup textaddr: self + c@  ret =  IF 1+ THEN
  326. ;m
  327.  
  328.  
  329. \ In the initial System 8, there's a bug in TEGetPoint - it expects a
  330. \  spurious initial parameter!  So for now I've kludged xcalls to say
  331. \  it has 3 parms.
  332.  
  333. :m GETPOINT:  { offset -- x y }    \ given the char offset into the text, return the
  334.                                 \ corresponding x y location  See IM V-269.
  335. \ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  336. \ Apparently the call TEGetPoint has a bug in current PPC implementations
  337. \ - the 2 parms are required to be in r4 and r5, instead of r3 and r4!
  338. \ So we have to kludge this particular call to think it takes one more
  339. \ cell than it really does.  If Apple fixes the bug, we'll need to delete
  340. \ this line.  There's also 2 lines in zCallsMod.txt.
  341.  
  342. [ ppc? ] [if]  0  [then]
  343.     
  344. \ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  345.  
  346.     offset  get: TEHandle  TEGetPoint  unpack  ;m
  347.  
  348.  
  349. :m currentLine:     ( -- n )
  350.     selend: self  getpoint: self  ( x y ) nip          ( cursor.y )
  351.     ptr: TEHandle ( dest) gettopy: rect  -            ( cursor.y - dest.top )
  352.     
  353.     lineheight: self / 1-
  354.     
  355.     selend: self  size: self =     \ true if at last char
  356.     size: self  and    \ and if not an empty size
  357.     IF
  358.         lastchar: self  ret =
  359.         IF    \ uh-oh, handle special case where last char is a ret
  360.             1+
  361.         THEN
  362.     THEN
  363.     ;m
  364.  
  365.  
  366. :m getLineN:  { n -- addr len }
  367.     n at: self dup  -> lineStart  -> lineEnd
  368.         \ set lineStart and lineEnd to char offs of curr line start in case we EXIT
  369.  
  370.     textaddr: self  lineStart +          \ addr of line start
  371.  
  372.     #lines: self 1 - n =
  373.     IF                                    \ we are on the last line
  374.         lastchar: self
  375.         ret =
  376.             IF        \ we are on the last line AND just beyond a carriage return!
  377.                 0  EXIT                    \ return zero len and get out
  378.             THEN
  379.  
  380.         size: self
  381.         lineStart -  ( len )
  382.     
  383.     ELSE        
  384.         linestart drop
  385.         n 1 + at: self
  386.         lineStart - 1 -  ( len )
  387.     THEN
  388.     ( len )  dup lineStart +  -> lineEnd
  389. ;m
  390.  
  391. :m getLine:  { \ n -- addr len }    \ returns the line with the current selection.
  392.  
  393.     size: self 0= IF textaddr: self 0 EXIT    THEN    \ out if no text
  394.  
  395.     currentLine: self -> n
  396.     n getLineN: self
  397. ;m
  398.  
  399.  
  400. :m LINEEND: { \ len pos -- pos }    \ return the character position corresponding to the
  401.                                     \ end of the last line of the current selection.
  402.     selend: self size: self =
  403.     IF    \ we are at the end of the text
  404.         size: self
  405.     ELSE
  406.         currentline: self  at: self  ( linestart ) -> pos
  407.         getline: self nip -> len
  408.         pos len +
  409.     THEN ;m
  410.  
  411. :m getselect: ( -- addr len )    \ returns hilited selection
  412.     ptr: TEHandle    getselect: teRecord  ;m
  413.  
  414. :m getSelect&lock:  ( hState addr len -- )
  415.     getSelect: self            \ I'll do this first, before locking the handle, since
  416.                             \  I can't assume TE won't unlock it
  417.     textHandle: self drop
  418.     getState: textHandle  down
  419.     lock: textHandle
  420. ;m
  421.  
  422.  
  423. :m IDLE:    \ May94 mh - Setting cursor now moved to TEScroller
  424.     get: TEHandle  TEIdle    
  425.  ;m
  426.  
  427. :m DUMP:
  428.     selstart: self
  429.     selend: self
  430.     currentline: self
  431.     lineEnd: self
  432.     size: self  { ss se cl le sz -- }
  433. \    ss " selstart "        >debug
  434. \    se " selend "            >debug
  435. \    cl " currentline "     >debug
  436. \    le " lineEnd "         >debug
  437. \    sz " size "             >debug
  438. ;m
  439.  
  440. ;CLASS
  441.